home *** CD-ROM | disk | FTP | other *** search
/ FM Towns: Software Contest 3 / FM Towns Software Contest 3.iso / exp / bpp / no1 / bpp.bas next >
BASIC Source File  |  1994-01-07  |  25KB  |  907 lines
  1. 10 ' *****************************************
  2. 20 ' ***                                   ***
  3. 30 ' ***     BPP - BASIC PreProcessor      ***
  4. 40 ' ***                                   ***
  5. 50 ' ***    Copyright (c) 1992 Fuko-CMC    ***
  6. 60 ' ***       Programmed by TmSof         ***
  7. 70 ' ***                                   ***
  8. 80 ' *****************************************
  9. 90 '
  10. 100 ' $FILE 13
  11. 110 '
  12. 120  DEFINT A-Z
  13. 130  VERSION$="Version 0.90"   ' *** Version number here! ***
  14. 140  DEF FNITOA$(I%)=MID$(STR$(I),2+(I%<0))
  15. 150  CDPLAYFLAG=0 ' *** CD auto playing 0.NO 1.YES ***
  16. 160 '
  17. 170 ' *** Grobal Defines ***
  18. 180 '
  19. 190  SEPARATOR$=" ,:!#$%()=-^\+*;<>?_/'"
  20. 200 '
  21. 210 ' *** Macro Define Symbol Table ***
  22. 220 '
  23. 230  MAXMACRO=255:MAXMACROPARAM=15:NUMOFMACDEF=0
  24. 240  DIM MACID$(MAXMACRO)      ' macro identifer
  25. 250  DIM MACRP$(MAXMACRO)      ' replace strings
  26. 260  DIM MACPC (MAXMACRO)      ' number of param.
  27. 270  DIM MACPA$(MAXMACRO,MAXMACROPARAM) ' Each param.
  28. 280  DIM MACTEMP$(MAXMACROPARAM)
  29. 290 '
  30. 300 ' *** Other Variables for PASS 1 ***
  31. 310 '
  32. 320  MAXINCLUDENEST=15:INCLUDENEST=0
  33. 330  DIM LINECOUNTER (MAXINCLUDENEST)
  34. 340 '
  35. 350 ' *** Block Structure Management Table ***
  36. 360 '
  37. 370  MAXBLOCKNEST=31:BLOCKNEST=0
  38. 380  DIM BLKTYP$(MAXBLOCKNEST)        ' block type
  39. 390  DIM BLKFLG$(MAXBLOCKNEST)        ' flags of structuring
  40. 400  DIM BLKEXITL$(MAXBLOCKNEST)      ' label id to exit the block
  41. 410  DIM BLKLOOPL$(MAXBLOCKNEST)      ' label id to loop the block
  42. 420 '
  43. 430 ' *** Sub-routines Declarations Symbol Table ***
  44. 440 '
  45. 450  MAXSUB=127:NUMOFSUB=0:MAXSUBPARAM=31
  46. 460  DIM SUBID$(MAXSUB)               ' identifer of sub-routine
  47. 470  DIM SUBPC(MAXSUB)                ' count of parameters
  48. 480  DIM SUBPARA(MAXSUB,MAXSUBPARAM)  ' parameter list
  49. 490  DIM SUBPTYP(MAXSUB,MAXSUBPARAM)  ' type of each parameters
  50. 500  DIM PARA$(MAXSUBPARAM)
  51. 510 '
  52. 520 ' *** Local Label Control ***
  53. 530 '
  54. 540  MAXLLAB=511:NUMOFLLAB=0
  55. 550  NUMOFBLKLLBL=0
  56. 560 '
  57. 570 ' *** Local Variable Symbol Table ***
  58. 580 '
  59. 590  STACKSIZE=511
  60. 600  STACKPTR$="ZZZSPT%"
  61. 610  STACKID$="ZZZSTK"
  62. 620  MAXLVAR=63
  63. 630  DIM NUMOFLVAR(3)         ' number of local variable
  64. 640  DIM LVARGID$(3,MAXLVAR)  ' grobal name of locals
  65. 650  FOR I=0 TO 3:NUMOFLVAR(I)=0:NEXT
  66. 660 '
  67. 670 ' *** BPP main ***
  68. 680 '
  69. 690 *MAIN
  70. 700  IF CDPLAYFLAG THEN GOSUB *CDSTART
  71. 710  PRINT
  72. 720  PRINT "BPP -- BASIC PreProsessor --  ";VERSION$
  73. 730  PRINT "Copyright (c) 1992 Fuko-CMC / Programmed by TmSof^^;"
  74. 740  PRINT
  75. 750 '
  76. 760  PRINT "Source Filename [.bpp] : ";:LINE INPUT SOURCEFILE$
  77. 770  P=INSTR(SOURCEFILE$,".")
  78. 780  IF P>0 THEN 820
  79. 790    FILEBASE$=SOURCEFILE$
  80. 800    SOURCEFILE$=SOURCEFILE$+".bpp"
  81. 810  GOTO 830
  82. 820    FILEBASE$=LEFT$(SOURCEFILE$,P-1)
  83. 830  OUTFILE$=FILEBASE$+".p1"
  84. 840  GOSUB *PASS1
  85. 850 '
  86. 860  SOURCEFILE$=OUTFILE$
  87. 870  OUTFILE$=FILEBASE$+".p2"
  88. 880  GOSUB *PASS2
  89. 890 '
  90. 900  SOURCEFILE$=OUTFILE$
  91. 910  OUTFILE$=FILEBASE$+".bas"
  92. 920  GOSUB *PASS3
  93. 930 '
  94. 940  PRINT
  95. 950  PRINT "Complete!!!"
  96. 960  IF CDPLAYFLAG THEN GOSUB *CDBREAK
  97. 970  END
  98. 980 '
  99. 990 ' *** CD Auto Player ^^; ... OMAKE ***
  100. 1000 '
  101. 1010 *CDSTART
  102. 1020  ON ERROR GOTO 1100
  103. 1030  CD PLAY
  104. 1040  ON ERROR GOTO 0
  105. 1050  INTERVAL 5
  106. 1060  ON INTERVAL GOSUB *CDCHECK
  107. 1070  INTERVAL ON
  108. 1080  RETURN
  109. 1090 '
  110. 1100  RESUME 1110
  111. 1110  ON ERROR GOTO 0
  112. 1120  CDPLAYFLAG=0
  113. 1130  RETURN 
  114. 1140 '
  115. 1150 *CDCHECK
  116. 1160  CDSTAT CDSTATUS
  117. 1170  IF CDSTATUS(1) THEN RETURN
  118. 1180  CD PLAY
  119. 1190  RETURN
  120. 1200 '
  121. 1210 *CDBREAK
  122. 1220  INTERVAL OFF
  123. 1230  CD STOP
  124. 1240  RETURN
  125. 1250 '
  126. 1260 ' *** KILL EXISTING FILE ***
  127. 1270 '
  128. 1280 *KILLFILE
  129. 1290  KILL OUTFILE$
  130. 1300  RESUME
  131. 1310 '
  132. 1320 ' *** PASS 1 : Pre-Preprcessing ***
  133. 1330 '
  134. 1340 *PASS1
  135. 1350  PRINT"PASS 1 --- Pre-Preprocessing"
  136. 1360  INCLUDENEST=0:LINECOUNTER(INCLUDENEST)=0
  137. 1370  LINES=0
  138. 1380  ON ERROR GOTO *KILLFILE
  139. 1390  OPEN OUTFILE$ FOR OUTPUT AS #1
  140. 1400  ON ERROR GOTO 0
  141. 1410  OPEN SOURCEFILE$ FOR INPUT AS #2
  142. 1420  PRINT#1,"' [ BPP PASS 1 ]"
  143. 1430  GOSUB *PREPRE
  144. 1440  CLOSE #1:CLOSE #2
  145. 1450  PRINT USING "##### lines done.";LINES
  146. 1460  RETURN
  147. 1470 '
  148. 1480 ' *** Get a line ***
  149. 1490 '
  150. 1500  LINECOUNTER(INCLUDENEST)=LINECOUNTER(INCLUDENEST)+1
  151. 1510  LINE INPUT#(INCLUDENEST+2),L$
  152. 1520  LINES=LINES+1
  153. 1530  PRINT USING "##### lines ..."+CHR$(13);LINES;
  154. 1540  RETURN
  155. 1550 '
  156. 1560 ' *** Body of Pre-Preprocessing
  157. 1570 '
  158. 1580 *PREPRE
  159. 1590  WHILE EOF(INCLUDENEST+2)=0
  160. 1600    GOSUB 1500
  161. 1610    GOSUB *TRIMLINE
  162. 1620    GOSUB *TOUPPER
  163. 1630    IF LEFT$(L$,1)="#" THEN GOSUB 1690 ELSE GOSUB 2120
  164. 1640  WEND
  165. 1650  RETURN
  166. 1660 '
  167. 1670 ' *** Pre-Presrocessor Command Jmp.Tbl. ***
  168. 1680 '
  169. 1690  PRINT#1,"'"+L$+" ";STRING$(INCLUDENEST+1,"#");
  170. 1700  PRINT#1,FNITOA$(LINECOUNTER(INCLUDENEST))
  171. 1710  GOSUB *GETTOKEN
  172. 1720  GOSUB *GETTOKEN
  173. 1730  IF TKN$="INCLUDE" THEN 1820
  174. 1740  IF TKN$="DEFINE" THEN 1960
  175. 1750  IF TKN$="IFDEF" THEN 2510
  176. 1760  IF TKN$="IFNDEF" THEN 2550
  177. 1770  IF TKN$="ENDIF" THEN 2840
  178. 1780  RETURN
  179. 1790 '
  180. 1800 ' *** INCLUDE ***
  181. 1810 '
  182. 1820  GOSUB *GETTOKEN
  183. 1830  IF TKN$="" THEN 1820
  184. 1840  'on error goto *****
  185. 1850  INCLUDENEST=INCLUDENEST+1
  186. 1860  LINECOUNTER(INCLUDENEST)=0
  187. 1870  OPEN TKN$ FOR INPUT AS #(INCLUDENEST+2)
  188. 1880  'on error goto 0
  189. 1890  GOSUB *PREPRE
  190. 1900  CLOSE #(INCLUDENEST+2)
  191. 1910  INCLUDENEST=INCLUDENEST-1
  192. 1920  RETURN
  193. 1930 '
  194. 1940 ' *** DEFINE ***
  195. 1950 '
  196. 1960  MNUM=NUMOFMACDEF
  197. 1970  GOSUB *GETTOKEN
  198. 1980  MACID$(MNUM)=TKN$
  199. 1990  IF SEP$<>"(" THEN MACPC(NMUM)=0:GOTO 2060
  200. 2000    PNUM=0
  201. 2010      GOSUB *GETTOKEN
  202. 2020      MACPA$(MNUM,PNUM)=TKN$
  203. 2030    IF SEP$<>")" THEN PNUM=PNUM+1:GOTO 2010
  204. 2040    MACPC(MNUM)=PNUM+1
  205. 2050    GOSUB *GETTOKEN
  206. 2060  MACRP$(MNUM)=L$
  207. 2070  NUMOFMACDEF=NUMOFMACDEF+1
  208. 2080  RETURN
  209. 2090 '
  210. 2100 ' *** Macro Replacing ***
  211. 2110 '
  212. 2120  GOSUB *GETTOKEN
  213. 2130  IF TKN$="" THEN 2450
  214. 2140  I=0
  215. 2150  WHILE I<NUMOFMACDEF
  216. 2160    IF TKN$<>MACID$(I) THEN 2430
  217. 2170      IF MACPC(I) THEN 2210
  218. 2180        PRINT#1,MACRP$(I);
  219. 2190        IF SEP$=CHR$(13) THEN PRINT#1,"" ELSE PRINT#1,SEP$;
  220. 2200        GOTO 2460
  221. 2210      PNUM=0
  222. 2220        MACTEMP$(PNUM)=""
  223. 2230        GOSUB *GETTOKEN
  224. 2240        MACTEMP$(PNUM)=MACTEMP$(PNUM)+TKN$
  225. 2250        IF SEP$=")" THEN 2290
  226. 2260        IF SEP$="," THEN PNUM=PNUM+1:GOTO 2220
  227. 2270        MACTEMP$(PNUM)=MACTEMP$(PNUM)+SEP$
  228. 2280        GOTO 2230
  229. 2290      PNUM=PNUM+1
  230. 2300      LBUF$=L$:TBUF$=TKN$:SBUF$=SEP$
  231. 2310      L$=MACRP$(I):R$=""
  232. 2320      GOSUB *GETTOKEN
  233. 2330      J=0
  234. 2340      WHILE J<MACPC(I)
  235. 2350        IF TKN$<>MACPA$(I,J) THEN 2370
  236. 2360          TKN$=MACTEMP$(J):GOTO 2390
  237. 2370      J=J+1
  238. 2380      WEND
  239. 2390      R$=R$+TKN$:IF SEP$<>CHR$(13) AND SEP$<>CHR$(34) THEN R$=R$+SEP$
  240. 2400      IF SEP$<>CHR$(13) THEN 2320
  241. 2410      L$=R$+LBUF$:TKN$=TBUF$:SEP$=SBUF$
  242. 2420      GOTO 2460
  243. 2430    I=I+1
  244. 2440  WEND
  245. 2450  GOSUB 2890
  246. 2460  IF SEP$<>CHR$(13) THEN 2120
  247. 2470  RETURN
  248. 2480 '
  249. 2490 ' *** IFDEF ***
  250. 2500 '
  251. 2510  COND=-1:GOTO 2590
  252. 2520 '
  253. 2530 ' *** IFNDEF ***
  254. 2540 '
  255. 2550  COND=0
  256. 2560 '
  257. 2570 ' *** Body of IFDEF/IFNDEF ***
  258. 2580 '
  259. 2590  GOSUB *GETTOKEN
  260. 2600  I=0:R=0
  261. 2610  WHILE I<NUMOFMACDEF
  262. 2620    IF TKN$=MACID$(I) THEN R=-1:GOTO 2660
  263. 2630    I=I+1
  264. 2640  WEND
  265. 2650  R=0
  266. 2660  IF R=COND THEN 2790
  267. 2670 ' [ else ]
  268. 2680  IFNEST=0
  269. 2690    GOSUB 1500
  270. 2700    GOSUB *TRIMLINE
  271. 2710    GOSUB *TOUPPER
  272. 2720    IF LEFT$(L$,3)="#IF" THEN IFNEST=IFNEST+1
  273. 2730    IF LEFT$(L$,6)<>"#ENDIF" THEN 2690
  274. 2740  IF IFNEST>0 THEN IFNEST=IFNEST-1:GOTO 2690
  275. 2750  PRINT#1,"'"+L$+" ";
  276. 2760  PRINT#1,STRING$(INCLUDENEST+1,"#");FNITOA$(LINECOUNTER(INCLUDENEST))
  277. 2770  RETURN
  278. 2780 ' [ then ]
  279. 2790  BLOCKNEST=BLOCKNEST+1
  280. 2800  RETURN
  281. 2810 '
  282. 2820 ' *** ENDIF ***
  283. 2830 '
  284. 2840  BLOCKNEST=BLOCKNEST-1
  285. 2850  RETURN
  286. 2860 '
  287. 2870 ' *** Output Token ***
  288. 2880 '
  289. 2890  IF SEP$=CHR$(34) THEN PRINT#1,TKN$;:RETURN
  290. 2900  IF SEP$<>CHR$(13) THEN PRINT#1,TKN$;SEP$;:RETURN
  291. 2910  LN$=FNITOA$(LINECOUNTER(INCLUDENEST))
  292. 2920  PRINT#1,TKN$+" '"+STRING$(INCLUDENEST+1,"#");
  293. 2930  PRINT#1,LN$
  294. 2940  RETURN
  295. 2950 '
  296. 2960 ' *** PASS 2 --- Block Structuring ***
  297. 2970 '
  298. 2980 *PASS2
  299. 2990  PRINT"PASS 2 --- Block Structuring"
  300. 3000  ON ERROR GOTO *KILLFILE
  301. 3010  OPEN OUTFILE$ FOR OUTPUT AS #1
  302. 3020  ON ERROR GOTO 0
  303. 3030  OPEN SOURCEFILE$ FOR INPUT AS #2
  304. 3040  BLOCKNEST=-1
  305. 3050  DEFAULTVARTYPE=0         'SNG
  306. 3060  INSUB=0:ELSEIF=0:LINES=0
  307. 3070  LM$="' [ BPP PASS 2 ]":LR$="":GOSUB 3170
  308. 3080  GOSUB *STRUC
  309. 3090  CLOSE #1:CLOSE #2
  310. 3100  PRINT USING "##### lines done.";LINES
  311. 3110  RETURN
  312. 3120 '
  313. 3130 ' *** Output a Line ***
  314. 3140 '                  [input] LM$    : content of the line
  315. 3150 '                          LR$    : comment of the line
  316. 3160 '
  317. 3170  PRINT#1,LM$;
  318. 3180  IF LR$<>"" THEN PRINT#1,"'"+LR$;
  319. 3190  PRINT#1,""
  320. 3200  LM$="":LR$=""
  321. 3210  RETURN
  322. 3220 '
  323. 3230 ' *** Get a Line ***
  324. 3240 '
  325. 3250  LINE INPUT #2,L$
  326. 3260  LINES=LINES+1
  327. 3270  PRINT USING "##### lines ..."+CHR$(13);LINES;
  328. 3280  QF=0
  329. 3290  FOR I=1 TO KLEN(L$)
  330. 3300    A$=KMID$(L$,I,1)
  331. 3310    IF A$=CHR$(34) THEN QF=1-QF
  332. 3320    IF A$="'" AND QF=0 THEN 3360
  333. 3330  NEXT
  334. 3340  RETURN
  335. 3350 '
  336. 3360  IF I<KLEN(L$) THEN LR$=KMID$(L$,I+1) ELSE LR$=""
  337. 3370  IF I>1 THEN L$=KMID$(L$,1,I-1) ELSE L$=""
  338. 3380  RETURN
  339. 3390 '
  340. 3400 ' *** Get a Token ***
  341. 3410 '
  342. 3420  GOSUB *GETTOKEN
  343. 3430  IF SEP$=CHR$(13) THEN EOL=-1 ELSE EOL=0
  344. 3440  IF SEP$=":" THEN SEP$=CHR$(13)
  345. 3450  RETURN
  346. 3460 '
  347. 3470 ' *** Build Structure ***
  348. 3480 '
  349. 3490 *STRUC
  350. 3500  WHILE EOF(2)=0
  351. 3510    IF L$="" THEN GOSUB 3250:GOSUB *TRIMLINE
  352. 3520      GOSUB 3420
  353. 3530      IF TKN$="SUB" THEN GOSUB 4020:GOTO 3760
  354. 3540      IF TKN$="ENDSUB" THEN GOSUB 4450:GOTO 3760
  355. 3550      IF TKN$="EXITSUB" THEN GOSUB 4590:GOTO 3760
  356. 3560      IF TKN$="FOR" THEN GOSUB 4700:GOTO 3760
  357. 3570      IF TKN$="NEXT" THEN GOSUB 5190:GOTO 3760
  358. 3580      IF TKN$="BREAK" THEN GOSUB 5500:GOTO 3760
  359. 3590      IF TKN$="IF" THEN GOSUB 5640:GOTO 3760
  360. 3600      IF TKN$="ENDIF" THEN GOSUB 5990:GOTO 3760
  361. 3610      IF TKN$="ELSEIF" THEN GOSUB 6080:GOTO 3760
  362. 3620      IF TKN$="WHILE" THEN GOSUB 6180:GOTO 3760
  363. 3630      IF TKN$="WEND" THEN GOSUB 6280:GOTO 3760
  364. 3640      IF TKN$="DO" THEN GOSUB 6360:GOTO 3760
  365. 3650      IF TKN$="LOOP" THEN GOSUB 6480:GOTO 3760
  366. 3660      IF TKN$="MAKESTACK" THEN GOSUB 6840:GOTO 3760
  367. 3670      IF TKN$="DEFSNG" THEN GOSUB 7100:GOTO 3760
  368. 3680      IF TKN$="DEFDBL" THEN GOSUB 7150:GOTO 3760
  369. 3690      IF TKN$="DEFSTR" THEN GOSUB 7200:GOTO 3760
  370. 3700      IF TKN$="DEFINT" THEN GOSUB 7250:GOTO 3760
  371. 3710 '
  372. 3720      IF TKN$="ELSE" THEN GOSUB 5850:GOTO 3760
  373. 3730      IF INSUB THEN GOSUB 3860
  374. 3740      LM$=LM$+TKN$
  375. 3750      IF SEP$=CHR$(34) THEN SEP$=""
  376. 3760    IF SEP$<>CHR$(13) THEN LM$=LM$+SEP$:GOSUB 3420:GOTO 3720
  377. 3770    GOSUB 3170
  378. 3780    IF EOL=0 THEN 3810
  379. 3790    IF BLOCKNEST<0 THEN 3810
  380. 3800      IF BLKTYP$(BLOCKNEST)="IF1" THEN GOSUB 5990:GOSUB 3170
  381. 3810  WEND
  382. 3820  RETURN
  383. 3830 '
  384. 3840 ' *** Solve Local Variable Relations ***
  385. 3850 '
  386. 3860  TYP=INSTR("!#$%",SEP$)-1
  387. 3870  IF TYP>=0 THEN S$=SEP$:T$=TKN$:GOSUB 3420:TKN$=T$
  388. 3880  IF TYP=-1 THEN TYP=DEFAULTVARTYPE:S$=""
  389. 3890  IF NUMOFLVAR(TYP)=0 THEN 3930
  390. 3900  FOR I=0 TO NUMOFLVAR(TYP)-1
  391. 3910    IF LVARGID$(TYP,I)=TKN$ THEN 3950
  392. 3920  NEXT
  393. 3930  SEP$=S$+SEP$
  394. 3940  RETURN
  395. 3950  TKN$=STACKID$+MID$("!#$%",TYP+1,1)
  396. 3960  TKN$=TKN$+"("+STACKPTR$+"("+FNITOA$(TYP)+")+"
  397. 3970  TKN$=TKN$+STK$+FNITOA$(I-NUMOFLVAR(TYP))+")"
  398. 3980  RETURN
  399. 3990 '
  400. 4000 ' *** SUB-routine Declaration ***
  401. 4010 '
  402. 4020  BLOCKNEST=BLOCKNEST+1
  403. 4030  FOR I=0 TO 3
  404. 4040    NUMOFLVAR(I)=0
  405. 4050  NEXT
  406. 4060  GOSUB 3420
  407. 4070  SUBID$(NUMOFSUB)=TKN$
  408. 4080  BLKEXITL$(BLOCKNEST)="ZZZ"+FNITOA$(NUMOFBLKLLBL)
  409. 4090  NUMOFBLKLLBL=NUMOFBLKLLBL+1
  410. 4100  LM$="*"+SUBID$(NUMOFSUB)
  411. 4110  IF SEP$="(" THEN GOSUB 4170 ELSE SUBPC(NUMOFSUB)=0
  412. 4120  GOSUB 6640:GOSUB 4350
  413. 4130  BLKTYP$(BLOCKNEST)="SUB"
  414. 4140  INSUB=1:SEP$=CHR$(13)
  415. 4150  RETURN
  416. 4160 ' [ get parameter list ]
  417. 4170  PNUM=0
  418. 4180    GOSUB 3420
  419. 4190    IF TKN$="" THEN 4310
  420. 4200    IF TKN$="BYBODY" THEN PBDY=1:GOSUB 3420 ELSE PBDY=0
  421. 4210    TYP=INSTR("!#$%",SEP$)-1
  422. 4220    IF TYP>=0 THEN T$=TKN$:GOSUB 3420:TKN$=T$
  423. 4230    IF TYP=-1 THEN TYP=DEFAULTVARTYPE
  424. 4240    GID$=TKN$
  425. 4250    LID=NUMOFLVAR(TYP)
  426. 4260    SUBPARA(NUMOFSUB,PNUM)=LID
  427. 4270    SUBPTYP(NUMOFSUB,PNUM)=TYP+PBDY*10
  428. 4280    LVARGID$(TYP,LID)=GID$
  429. 4290    NUMOFLVAR(TYP)=LID+1
  430. 4300    PNUM=PNUM+1
  431. 4310  IF SEP$<>")" GOTO 4180
  432. 4320  SUBPC(NUMOFSUB)=PNUM
  433. 4330  RETURN
  434. 4340 ' [ shift stack pointer ]
  435. 4350  FOR I=0 TO 3
  436. 4360    IF NUMOFLVAR(I)=0 THEN 4400
  437. 4370    GOSUB 3170
  438. 4380    SP$=STACKPTR$+"("+FNITOA$(I)+")"
  439. 4390    LM$=SP$+"="+SP$+"+"+FNITOA$(NUMOFLVAR(I))
  440. 4400  NEXT
  441. 4410  RETURN
  442. 4420 '
  443. 4430 ' *** End of SUB-routine Declaration ***
  444. 4440 '
  445. 4450  INSUB=0
  446. 4460  LM$="*"+BLKEXITL$(BLOCKNEST):GOSUB 3170
  447. 4470  FOR I=0 TO 3
  448. 4480    IF NUMOFLVAR(I)=0 THEN 4510
  449. 4490    SP$=STACKPTR$+"("+FNITOA$(I)+")"
  450. 4500    LM$=SP$+"="+SP$+"-"+FNITOA$(NUMOFLVAR(I)):GOSUB 3170
  451. 4510  NEXT
  452. 4520  LM$="RETURN":SEP$=CHR$(13)
  453. 4530  NUMOFSUB=NUMOFSUB+1
  454. 4540  BLOCKNEST=BLOCKNEST-1
  455. 4550  RETURN
  456. 4560 '
  457. 4570 ' *** EXITSUB ***
  458. 4580 '
  459. 4590  'if insub=0 then !error
  460. 4600  FOR I=BLKNEST TO 0 STEP -1
  461. 4610    IF BLKTYP$(I)="SUB" THEN 4640
  462. 4620  NEXT
  463. 4630  RETURN
  464. 4640  LM$="GOTO *"+BLKEXITL$(I)
  465. 4650  SEP$=CHR$(13)
  466. 4660  RETURN
  467. 4670 '
  468. 4680 ' *** FOR ***
  469. 4690 '
  470. 4700  T$=TKN$:S$=SEP$:LB$=""
  471. 4710    GOSUB 3420
  472. 4720    LB$=LB$+TKN$
  473. 4730    IF SEP$=CHR$(13) THEN 5090
  474. 4740    IF SEP$="," THEN 4780
  475. 4750    IF SEP$<>CHR$(34) THEN LB$=LB$+SEP$
  476. 4760  GOTO 4710
  477. 4770 ' [ FOR statment type 2 ]
  478. 4780  BLOCKNEST=BLOCKNEST+1
  479. 4790  LM$=LM$+LB$:GOSUB 3170
  480. 4800  LB$="ZZZ"+FNITOA$(NUMOFBLKLLBL)
  481. 4810  LM$="*"+LB$:GOSUB 3170
  482. 4820  BLKLOOPL$(BLOCKNEST)=LB$
  483. 4830  NUMOFBLKLLBL=NUMOFBLKLLBL+1
  484. 4840  BLKTYP$(BLOCKNEST)="FOR"
  485. 4850  BNEST=0
  486. 4860  LB$=""
  487. 4870    GOSUB 3420
  488. 4880    LB$=LB$+TKN$
  489. 4890    IF SEP$="(" THEN BNEST=BNEST+1
  490. 4900    IF SEP$=")" THEN BNEST=BNEST-1
  491. 4910    IF SEP$="," AND BNEST=0 THEN 4940
  492. 4920    IF SEP$<>CHR$(34) THEN LB$=LB$+SEP$
  493. 4930  GOTO 4870
  494. 4940  EL$="ZZZ"+FNITOA$(NUMOFBLKLLBL)
  495. 4950  NUMOFBLKLLBL=NUMOFBLKLLBL+1
  496. 4960  LZ$="IF ("+LB$+")=0 THEN *"+EL$
  497. 4970  BLKEXITL$(BLOCKNEST)=EL$
  498. 4980  LB$=""
  499. 4990    GOSUB 3420
  500. 5000    LB$=LB$+TKN$
  501. 5010    IF SEP$=CHR$(13) THEN 5040
  502. 5020    IF SEP$<>CHR$(34) THEN LB$=LB$+SEP$
  503. 5030  GOTO 4990
  504. 5040  BLKFLG$(BLOCKNEST)=LB$
  505. 5050  TKN$="":SEP$=""
  506. 5060  IF L$="" THEN L$=LZ$ ELSE L$=LZ$+":"+L$
  507. 5070  RETURN
  508. 5080 ' [ FOR statment type 1 (STANDARD) ]
  509. 5090  BLOCKNEST=BLOCKNEST+1
  510. 5100  LZ$=T$+S$+LB$:TKN$="":SEP$=""
  511. 5110  IF L$="" THEN L$=LZ$ ELSE L$=LZ$+":"+L$
  512. 5120  BLKTYP$(BLOCKNEST)="FOR1"
  513. 5130  BLKEXITL$(BLOCKNEST)="ZZZ"+FNITOA$(NUMOFBLKLLBL)
  514. 5140  NUMOFBLKLLBL=NUMOFBLKLLBL+1
  515. 5150  RETURN
  516. 5160 '
  517. 5170 ' *** NEXT ***
  518. 5180 '
  519. 5190  IF BLKTYP$(BLOCKNEST)="FOR" THEN 5230
  520. 5200  IF BLKTYP$(BLOCKNEST)="FOR1" THEN 5370
  521. 5210  RETURN 'ERROR!
  522. 5220 ' [ type 2 ]
  523. 5230  LL$=BLKFLG$(BLOCKNEST)
  524. 5240  LL$=LL$+":GOTO *"+BLKLOOPL$(BLOCKNEST)
  525. 5250  LL$=LL$+":*"+BLKEXITL$(BLOCKNEST)
  526. 5260  LB$=""
  527. 5270  WHILE SEP$<>CHR$(13)
  528. 5280    GOSUB 3420
  529. 5290    LB$=LB$+TKN$
  530. 5300    IF SEP$<>CHR$(13) AND SEP$<>CHR$(34) THEN LB$=LB$+SEP$
  531. 5310  WEND
  532. 5320  IF L$="" THEN L$=LL$ ELSE L$=LL$+":"+L$
  533. 5330  SEP$=""
  534. 5340  BLOCKNEST=BLOCKNEST-1
  535. 5350  RETURN
  536. 5360 ' [ type 1 ]
  537. 5370  LB$=""
  538. 5380  WHILE SEP$<>CHR$(13)
  539. 5390    GOSUB 3420
  540. 5400    LB$=LB$+TKN$
  541. 5410    IF SEP$<>CHR$(13) AND SEP$<>CHR$(34) THEN LB$=LB$+SEP$
  542. 5420  WEND
  543. 5430  LB$="NEXT "+LB$+":*"+BLKEXITL$(BLOCKNEST)
  544. 5440  IF L$="" THEN L$=LB$ ELSE L$=LB$+":"+L$
  545. 5450  SEP$=""
  546. 5460  BLOCKNEST=BLOCKNEST-1
  547. 5470  RETURN
  548. 5480 '
  549. 5490 ' *** BREAK ***
  550. 5500 '
  551. 5510  IF BLOCKNEST=-1 THEN RETURN 'ERROR!
  552. 5520  FOR I=BLOCLNEST TO 0 STEP -1
  553. 5530    IF BLKTYP$(I)="FOR" OR BLKTYP$(I)="FOR1" THEN 5580
  554. 5540    IF BLKTYP$(I)="DO" OR BLKTYP$(I)="WHILE" THEN 5580
  555. 5550  NEXT
  556. 5560  RETURN '!ERROR
  557. 5570 '
  558. 5580  LM$="GOTO *"+BLKEXITL$(I)
  559. 5590  SEP$=""
  560. 5600  RETURN
  561. 5610 '
  562. 5620 ' *** block IF ***
  563. 5630 '
  564. 5640  LB$=""
  565. 5650    GOSUB 3420
  566. 5660    IF TKN$="THEN" THEN 5710
  567. 5670    LB$=LB$+TKN$
  568. 5680    IF SEP$<>CHR$(34) THEN LB$=LB$+SEP$
  569. 5690  GOTO 5650
  570. 5700 '
  571. 5710  IF ELSEIF=0 THEN BLOCKNEST=BLOCKNEST+1
  572. 5720  IF SEP$=CHR$(13) THEN BLKTYP$(BLOCKNEST)="IF":GOTO 5740 '[ type 2 ]
  573. 5730  BLKTYP$(BLOCKNEST)="IF1":SEP$="" '[ type 1 ]
  574. 5740  LL$="ZZZ"+FNITOA$(NUMOFBLKLLBL)
  575. 5750  NUMOFBLKLLBL=NUMOFBLKLLBL+1
  576. 5760  BLKLOOPL$(BLOCKNEST)=LL$
  577. 5770  IF ELSEIF=0 THEN BLKEXITL$(BLOCKNEST)=""
  578. 5780  LB$="IF ("+LB$+")=0 THEN *"+LL$
  579. 5790  IF L$="" THEN L$=LB$ ELSE L$=LB$+":"+L$
  580. 5800  SEP$=""
  581. 5810  RETURN
  582. 5820 '
  583. 5830 ' *** ELSE ***
  584. 5840 '
  585. 5850  IF LM$<>"" THEN GOSUB 3170
  586. 5860  IF BLKEXITL$(BLOCKNEST)="" THEN 5890
  587. 5870    LL$=BLKEXITL$(BLOCKNEST)
  588. 5880  GOTO 5920
  589. 5890    LL$="ZZZ"+FNITOA$(NUMOFBLKLLBL)
  590. 5900    NUMOFBLKLLBL=NUMOFBLKLLBL+1
  591. 5910    BLKEXITL$(BLOCKNEST)=LL$
  592. 5920  LM$="GOTO *"+LL$:GOSUB 3170
  593. 5930  LM$="*"+BLKLOOPL$(BLOCKNEST)
  594. 5940  SEP$=CHR$(13)
  595. 5950  RETURN
  596. 5960 '
  597. 5970 ' *** ENDIF ***
  598. 5980 '
  599. 5990  IF BLKEXITL$(BLOCKNEST)="" THEN LM$="*"+BLKLOOPL$(BLOCKNEST):GOTO 6010
  600. 6000  LM$="*"+BLKEXITL$(BLOCKNEST)
  601. 6010  BLOCKNEST=BLOCKNEST-1
  602. 6020  SEP$=CHR$(13)
  603. 6030  RETURN
  604. 6040 '
  605. 6050 ' *** ELSEIF ***
  606. 6060 '
  607. 6070 '[ ELSE ]
  608. 6080  GOSUB 5850 ' [ ELSE ]
  609. 6090  GOSUB 3170
  610. 6100 ' [ IF ]
  611. 6110  ELSEIF=1
  612. 6120  GOSUB 5640 '[ IF ]
  613. 6130  ELSEIF=0
  614. 6140  RETURN
  615. 6150 '
  616. 6160 ' *** WHILE ***
  617. 6170 '
  618. 6180  BLOCKNEST=BLOCKNEST+1
  619. 6190  BLKTYP$(BLOCKNEST)="WHILE"
  620. 6200  LL$="ZZZ"+FNITOA$(NUMOFBLKLLBL)
  621. 6210  NUMOFBLKLLBL=NUMOFBLKLLBL+1
  622. 6220  BLKEXITL$(BLOCKNEST)=LL$
  623. 6230  L$="WHILE "+L$:SEP$=""
  624. 6240  RETURN
  625. 6250 '
  626. 6260 ' *** WEND ***
  627. 6270 '
  628. 6280  LL$="WEND:*"+BLKEXITL$(BLOCKNEST)
  629. 6290  IF L$="" THEN L$=LL$ ELSE L$=LL$+":"+L$
  630. 6300  BLOCKNEST=BLOCKNEST-1
  631. 6310  SEP$=""
  632. 6320  RETURN
  633. 6330 '
  634. 6340 ' *** DO ***
  635. 6350 '
  636. 6360  BLOCKNEST=BLOCKNEST+1
  637. 6370  LL$="ZZZ"+FNITOA$(NUMOFBLKLLBL)
  638. 6380  NUMOFBLKLLBL=NUMOFBLKLLBL+1
  639. 6390  LM$="*"+LL$:SEP$=CHR$(13)
  640. 6400  BLKLOOPL$(BLOCKNEST)=LL$
  641. 6410  LL$="ZZZ"+FNITOA$(NUMOFBLKLLBL)
  642. 6420  NUMOFBLKLLBL=NUMOFBLKLLBL+1
  643. 6430  BLKEXITL$(BLOCKNEST)=LL$
  644. 6440  RETURN
  645. 6450 '
  646. 6460 ' *** LOOP ***
  647. 6470 '
  648. 6480  LL$="IF "
  649. 6490    GOSUB 3420
  650. 6500    LL$=LL$+TKN$
  651. 6510    IF SEP$=CHR$(13) THEN 6550
  652. 6520    IF SEP$<>CHR$(34) THEN LL$=LL$+SEP$
  653. 6530  GOTO 6490
  654. 6540 '
  655. 6550  LL$=LL$+" THEN *"+BLKLOOPL$(BLOCKNEST)
  656. 6560  LL$=LL$+":*"+BLKEXITL$(BLOCKNEST)
  657. 6570  IF L$="" THEN L$=LL$ ELSE L$=LL$+":"+L$
  658. 6580  SEP$=""
  659. 6590  BLOCKNEST=BLOCKNEST-1
  660. 6600  RETURN
  661. 6610 '
  662. 6620 ' *** LOCAL ***
  663. 6630 '
  664. 6640  IF L$="" THEN GOSUB 3250:GOSUB *TRIMLINE
  665. 6650  GOSUB 3420
  666. 6660  IF TKN$="LOCAL" THEN 6720
  667. 6670  IF SEP$=CHR$(34) THEN SEP$=""
  668. 6680  IF SEP$=CHR$(13) THEN IF L$="" THEN SEP$="" ELSE SEP$=":"
  669. 6690  L$=TKN$+SEP$+L$
  670. 6700  RETURN
  671. 6710 '
  672. 6720    GOSUB 3420
  673. 6730    IF TKN$="" THEN 6790
  674. 6740    TYP=INSTR("!#$%",SEP$)-1
  675. 6750    IF TYP>=0 THEN GOSUB 3420
  676. 6760    IF TYP=-1 THEN TYP=DEFAULTVARTYPE
  677. 6770    LVARGID$(TYP,NUMOFLVAR(TYP))=TKN$
  678. 6780    NUMOFLVAR(TYP)=NUMOFLVAR(TYP)+1
  679. 6790  IF SEP$<>CHR$(13) THEN 6720
  680. 6800  GOTO 6640
  681. 6810 '
  682. 6820 ' *** MAKESTACK ***
  683. 6830 '
  684. 6840  LM$="'[ STACK FRAME ]":GOSUB 3170
  685. 6850  FOR I=0 TO 2
  686. 6860    LL$=""
  687. 6870      GOSUB 3420
  688. 6880      LL$=LL$+TKN$
  689. 6890      IF SEP$="," THEN 6930
  690. 6900      IF SEP$<>CHR$(34) THEN LL$=LL$+SEP$
  691. 6910    GOTO 6870
  692. 6920 '
  693. 6930    LM$="DIM "+STACKID$+MID$("!#$",I+1,1)+"("+LL$+")":GOSUB 3170
  694. 6940    LM$=STACKPTR$+"("+FNITOA$(I)+")=0":GOSUB 3170
  695. 6950  NEXT
  696. 6960 '
  697. 6970  LL$=""
  698. 6980    GOSUB 3420
  699. 6990    LL$=LL$+TKN$
  700. 7000    IF SEP$=CHR$(13) THEN 7040
  701. 7010    IF SEP$<>CHR$(34) THEN LL$=LL$+SEP$
  702. 7020  GOTO 6980
  703. 7030 '
  704. 7040  LM$="DIM "+STACKID$+"%("+LL$+")":GOSUB 3170
  705. 7050  LM$=STACKPTR$+"(3)=0"
  706. 7060  RETURN
  707. 7070 '
  708. 7080 ' *** DEFSNG ***
  709. 7090 '
  710. 7100  DEFAULTVARTYPE=0
  711. 7110  GOTO 7260
  712. 7120 '
  713. 7130 ' *** DEFDBL ***
  714. 7140 '
  715. 7150  DEFAULTVARTYPE=1
  716. 7160  GOTO 7260
  717. 7170 '
  718. 7180 ' *** DEFSTR ***
  719. 7190 '
  720. 7200  DEFAULTVARTYPE=2
  721. 7210  GOTO 7260
  722. 7220 '
  723. 7230 ' *** DEFINT ***
  724. 7240 '
  725. 7250  DEFAULTVARTYPE=3
  726. 7260  WHILE SEP$<>CHR$(13)
  727. 7270    GOSUB 3420
  728. 7280  WEND
  729. 7290  RETURN
  730. 7300 '
  731. 7310 ' *** PASS 3 ***
  732. 7320 '
  733. 7330 *PASS3
  734. 7340  PRINT "PASS 3 --- Solve Sub-routine Calls"
  735. 7350  ON ERROR GOTO *KILLFILE
  736. 7360  OPEN OUTFILE$ FOR OUTPUT AS #1
  737. 7370  ON ERROR GOTO 0
  738. 7380  OPEN SOURCEFILE$ FOR INPUT AS #2
  739. 7390  LINENO=10:LINES=0
  740. 7400  LM$="' [ BPP PASS 3 ]":LR$="":GOSUB 7450
  741. 7410  GOSUB *SOLVESUB
  742. 7420  CLOSE #1:CLOSE #2
  743. 7430  PRINT USING "##### lines done.";LINES
  744. 7440  RETURN
  745. 7450 '
  746. 7460 ' *** Output a Line ***
  747. 7470 '                 [input]  LINENO : line number
  748. 7480 '                          LM$    : content of the line
  749. 7490 '                          LR$    : comment of the line
  750. 7500 '
  751. 7510  LN$=FNITOA$(LINENO)+" "
  752. 7520  LINENO=LINENO+10
  753. 7530  PRINT#1,LN$+LM$;
  754. 7540  IF LR$<>"" THEN PRINT#1,"'"+LR$;
  755. 7550  PRINT#1,""
  756. 7560  LM$="":LR$=""
  757. 7570  RETURN
  758. 7580 '
  759. 7590 ' *** Solve Relations of Sub-routines ***
  760. 7600 '
  761. 7610 *SOLVESUB
  762. 7620  WHILE EOF(2)=0
  763. 7630    GOSUB 3250 'get a line
  764. 7640    LL$=L$
  765. 7650    GOSUB 3420 'get a token
  766. 7660    IF TKN$="CALL" THEN GOSUB 7750:GOTO 7690
  767. 7670    LM$=LL$
  768. 7680    GOSUB 7450 'put a line with line number
  769. 7690  WEND
  770. 7700  RETURN
  771. 7710 '
  772. 7720 '
  773. 7730 ' *** CALL ***
  774. 7740 '
  775. 7750  GOSUB 3420
  776. 7760  SID$=TKN$
  777. 7770  GOSUB 7820 'set prameters
  778. 7780  LM$="GOSUB *"+SID$:GOSUB 7450
  779. 7790  GOSUB 8080 'get return value
  780. 7800  RETURN
  781. 7810 '
  782. 7820  IF NUMOFSUB=0 THEN 7860
  783. 7830  FOR I=0 TO NUMOFSUB-1
  784. 7840    IF SID$=SUBID$(I) THEN 7880
  785. 7850  NEXT
  786. 7860  SID=-1:PNUM=0:RETURN
  787. 7870 '
  788. 7880  SID=I:PNUM=SUBPC(I)
  789. 7890  BNEST=0
  790. 7900  IF PNUM=0 THEN RETURN
  791. 7910  FOR I=0 TO PNUM-1
  792. 7920    LL$=""
  793. 7930      GOSUB 3420
  794. 7940      LL$=LL$+TKN$
  795. 7950      IF SEP$="(" THEN BNEST=BNEST+1
  796. 7960      IF SEP$=")" THEN IF BNEST=0 THEN 8010 ELSE BNEST=BNEST-1
  797. 7970      IF SEP$="," OR SEP$=CHR$(13) THEN 8010
  798. 7980      IF SEP$<>CHR$(34) THEN LL$=LL$+SEP$
  799. 7990    GOTO 7930
  800. 8000 '
  801. 8010    TYP=SUBPTYP(SID,I) MOD 10:LID=SUBPARA(SID,I)
  802. 8020    PARA$(I)=LL$
  803. 8030    LM$=STACKID$+MID$("!#$%",TYP+1,1)+"("
  804. 8040    LM$=LM$+STACKPTR$+"("+FNITOA$(TYP)+")+"+FNITOA$(LID)+")="
  805. 8050    LM$=LM$+LL$:GOSUB 7450
  806. 8060  NEXT
  807. 8070 '
  808. 8080  FOR I=0 TO PNUM-1
  809. 8090    IF SUBPTYP(SID,I)<10 THEN 8150
  810. 8100      LM$=PARA$(I)+"="
  811. 8110      LM$=LM$+STACKID$+MID$("!#$%",(SUBPTYP(SID,I) MOD 10)+1,1)+"("
  812. 8120      LM$=LM$+STACKPTR$+"("+FNITOA$(SUBPTYP(SID,I) MOD 10)+")+"
  813. 8130      LM$=LM$+FNITOA$(SUBPARA(SID,I))+")"
  814. 8140      GOSUB 7450
  815. 8150  NEXT
  816. 8160  RETURN
  817. 8170 '
  818. 8180 ' *** Get a Token ***
  819. 8190 '
  820. 8200 '         [input]  L$
  821. 8210 '         [output] TKN$ : extracted token
  822. 8220 '                  SEP$ : separator
  823. 8230 '                  L$   : one token deleted
  824. 8240 '
  825. 8250 *GETTOKEN
  826. 8260  IF LEFT$(L$,1)=CHR$(34) THEN 8480
  827. 8270  Z0=1
  828. 8280  WHILE Z0<=LEN(L$)
  829. 8290    Z0$=MID$(L$,Z0,1)
  830. 8300    IF Z0$=CHR$(34) THEN 8440
  831. 8310    Z1=1
  832. 8320    WHILE Z1<=LEN(SEPARATOR$)
  833. 8330      IF Z0$=MID$(SEPARATOR$,Z1,1) THEN 8410
  834. 8340    Z1=Z1+1
  835. 8350    WEND
  836. 8360  Z0=Z0+1
  837. 8370  WEND
  838. 8380  TKN$=L$:SEP$=CHR$(13):L$=""
  839. 8390  RETURN
  840. 8400 ' separator found
  841. 8410  IF Z0=1 THEN TKN$="":SEP$=LEFT$(L$,1):L$=MID$(L$,2):RETURN
  842. 8420  TKN$=LEFT$(L$,Z0-1):SEP$=MID$(L$,Z0,1):L$=MID$(L$,Z0+1)
  843. 8430  RETURN
  844. 8440 ' quautation found
  845. 8450  TKN$=LEFT$(L$,Z0-1):SEP$=" ":L$=MID$(L$,Z0)
  846. 8460  RETURN
  847. 8470 ' quauted string
  848. 8480  IF LEN(L$)=1 THEN L$=L$+CHR$(34)
  849. 8490  Z0=INSTR(MID$(L$,2),CHR$(34))
  850. 8500  IF Z0=0 THEN L$=L$+CHR$(34):Z0=LEN(L$)
  851. 8510  TKN$=LEFT$(L$,Z0+1):SEP$=CHR$(34)
  852. 8520  IF Z0+1=LEN(L$) THEN L$="" ELSE L$=MID$(L$,Z0+2)
  853. 8530  RETURN
  854. 8540 '
  855. 8550 ' *** Trimming a Line ***
  856. 8560 '
  857. 8570 '         [input]  L$
  858. 8580 '         [output] L$
  859. 8590 '
  860. 8600 *TRIMLINE
  861. 8610  Z0=1:Z0$=L$:L$="":Z2$=""
  862. 8620 '
  863. 8630  IF Z0>LEN(Z0$) THEN RETURN
  864. 8640    Z1$=MID$(Z0$,Z0,1)
  865. 8650  IF Z1$=" " OR Z1$=CHR$(9) THEN Z0=Z0+1:GOTO 8630
  866. 8660  L$=L$+Z2$:Z2$=" "
  867. 8670 '
  868. 8680  IF Z0>LEN(Z0$) THEN RETURN
  869. 8690    Z1$=MID$(Z0$,Z0,1)
  870. 8700    IF Z1$="'" THEN RETURN
  871. 8710    IF Z1$=" " OR Z1$=CHR$(9) THEN 8630
  872. 8720    IF Z1$=CHR$(34) THEN 8750
  873. 8730  L$=L$+Z1$:Z0=Z0+1:GOTO 8680
  874. 8740 ' quautation found
  875. 8750  L$=L$+CHR$(34)
  876. 8760  Z0=Z0+1:IF Z0>LEN(Z0$) THEN L$=L$+CHR$(34):RETURN
  877. 8770  Z1=INSTR(MID$(Z0$,Z0),CHR$(34))
  878. 8780  IF Z1=0 THEN L$=L$+CHR$(34):RETURN
  879. 8790  L$=L$+MID$(Z0$,Z0,Z1)
  880. 8800  Z0=Z0+Z1:GOTO 8630
  881. 8810 '
  882. 8820 ' *** To Upper ***
  883. 8830 '
  884. 8840 '         [input]  L$
  885. 8850 '         [output] L$
  886. 8860 '
  887. 8870 *TOUPPER
  888. 8880  Z0$=L$:L$="":Z1=0
  889. 8890  FOR Z0=1 TO KLEN(Z0$)
  890. 8900    Z1$=KMID$(Z0$,Z0,1)
  891. 8910    IF Z1$=CHR$(34) THEN Z1=1-Z1
  892. 8920    IF Z1 THEN 8940
  893. 8930      IF Z1$>="a" AND Z1$<="z" THEN Z1$=CHR$(ASC(Z1$)-32)
  894. 8940    L$=L$+Z1$
  895. 8950  NEXT
  896. 8960  RETURN
  897. 8970 '
  898. 8980 ' *** Output Token ***
  899. 8990 '
  900. 9000 '         [input] TKN$, SEP$
  901. 9010 '
  902. 9020 *OUTTOKEN
  903. 9030  IF SEP$=CHR$(13) THEN PRINT#1,TKN$ :RETURN
  904. 9040  IF SEP$=CHR$(34) THEN PRINT#1,TKN$;:RETURN
  905. 9050  PRINT TKN$;SEP$;
  906. 9060  RETURN
  907.